home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
selfile.zip
/
SELFILE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
30KB
|
945 lines
{
+--------------------------------------------------------------+
| |
| Unit: Selfile Version: 3.0 |
| |
| Copyright (c) 1988 Repstad Computer Consultants |
| RFD #1, Box 3720 |
| Sheldon, VT 05483 |
| (802) 933-5133 (Voice) |
| (802) 933-2417 (Data - Black Creek BBS)|
| |
| All Rights Reserved |
| |
| This TP4.0 Unit is shareware...a $10.00 contribution is |
| suggested. See Selfile.Doc for more info on this unit. |
| |
| |
+--------------------------------------------------------------+
}
unit selfile;
Interface
Uses Crt,Dos;
{
+----------------------------------------------------+
| Define interface functions/procedures |
+----------------------------------------------------+
}
function Sel_File(Var Fil_Nam : String; title, path : String;
attribute : byte) : Integer;
procedure SetLim(rowb,
colb,
rowq,
colq,
active,
inactive,
boarder : Integer);
{
+----------------------------------------------------+
| Begin Unit Implementation |
+----------------------------------------------------+
}
Implementation
{
+----------------------------------------------------+
| Define data types for unit |
+----------------------------------------------------+
}
Type
Fptr = ^File_Rec;
File_Rec = Record
Filnam : String[12];
Next : Fptr;
Prev : Fptr;
End;
sstr_type = string[12];
{
+----------------------------------------------------+
| Define constants for unit |
+----------------------------------------------------+
}
Const
LHIGHLITE = 112; { Black w/ White Background }
LNORMAL = 31; { White w/ Blue Background }
DEF_BDR = 1; { Default boarder = double line }
{ Boarder types are:
0 = No boarder
1 = Double line
2 = Single Line
3 = +-| chars }
{
+----------------------------------------------------+
| Define Globals for unit |
+----------------------------------------------------+
}
Var
Row_Begin : Integer; { Absolute screen Row/Col for }
Col_Begin : Integer; { location of Upper Left Corner }
{ of file selection window }
Row_Quan : Integer; { Number of rows }
Col_Quan : Integer; { Number of cols }
Act_Attr : Integer; { Active (highlighted) file vid attr}
IAct_Attr : Integer; { Inactive file video attribute }
Save_Attr : Integer; { Save current text attribute }
Wndw_Bdr : Integer; { File selection window boarder type}
F_Col_Max : Integer; { Max Col to put file name at }
F_Row_Max : Integer; { Max Row to put file name at }
Cur_Col : Integer; { Current column }
Cur_Row : Integer; { Current Row }
Row_Beg : Integer; { Beginning row of window }
Col_Beg : Integer; { Beginning col of window }
Save_WMin : Word; { Save area for WindMin & WindMax }
Save_WMax : Word;
HPtr : Pointer; { Pointer to heap for mark/release }
vidc : Byte Absolute $B800:0000; { Pointer to color video mem }
vidm : Byte Absolute $B000:0000; { Pointer to b/w video memory }
screen : Array [1..4000] of Byte;
vptr : Pointer; { screen save mem pointer }
{
+----------------------------------------------------+
| Begin Unit SelFile Procedures |
+----------------------------------------------------+
}
{
+----------------------------------------------------+
| Procedure beepit |
+----------------------------------------------------+
}
Procedure beepit;
Begin
sound(440); { Beep the speaker }
delay(200);
nosound;
end;
{
+----------------------------------------------------+
| Function ISCOLOR |
+----------------------------------------------------+
}
Function ISCOLOR : Boolean;
Var
regs : Registers;
video_mode : Integer;
equ_lo : Byte;
Begin
Intr($11,regs); { Determin video type }
video_mode := regs.al AND $30;
video_mode := video_mode SHR 4;
Case video_mode of
1 : ISCOLOR := FALSE;
2 : ISCOLOR := TRUE;
End;
End;
{
+----------------------------------------------------+
| Procedure Highlight |
+----------------------------------------------------+
}
Procedure Highlight(ptr : Fptr);
Begin
TextAttr := Act_Attr; { Highlight a file name }
GoToXY(Cur_Col-1,Cur_Row);
Write('',ptr^.filnam,'');
TextAttr := IAct_Attr;
End;
{
+----------------------------------------------------+
| Procedure Un_Highlight |
+----------------------------------------------------+
}
Procedure Un_Highlight(ptr : Fptr);
Begin
TextAttr := IAct_Attr; { Un-Highlight a file name }
GoToXY(Cur_Col-1,Cur_Row);
Write(' ',ptr^.filnam,' ');
End;
{
+----------------------------------------------------+
| Procedure Save_Screen |
+----------------------------------------------------+
}
Procedure Save_Screen;
Begin
Save_WMin := WindMin; { Save the current window }
Save_WMax := WindMax; { min/max coordinates }
Save_Attr := TextAttr;
If (NOT ISCOLOR) Then { Move screen image to }
Move(vidm,screen,4000) { Heap depending on video }
Else { Card Type }
Move(vidc,screen,4000);
End;
{
+----------------------------------------------------+
| Procedure Restore_Screen |
+----------------------------------------------------+
}
Procedure Restore_Screen;
Begin;
WindMin := Save_WMin; { Restore original window }
WindMax := Save_WMax; { min/max coordinates }
TextAttr := Save_Attr;
If (NOT ISCOLOR) Then { Restore original screen }
Move(screen,vidm,4000) { image from the Heap }
Else
Move(screen,vidc,4000);
End;
{
+----------------------------------------------------+
| Procedure Cursor |
+----------------------------------------------------+
}
Procedure Cursor(attrib : Boolean);
Var
regs : Registers;
Begin
If (NOT attrib) Then { Turn cursor on/off }
Begin
regs.ah := 1;
regs.cl := 7;
regs.ch := 32;
Intr($10,regs);
End
Else
Begin
Intr($11,regs);
regs.cx := $0607;
If ((regs.al AND $10) <> 0) Then
regs.cx := $0B0C;
regs.ah := 1;
Intr($10,regs);
End;
End;
Procedure Wchars(ch : char; attr : byte; count : Integer);
Type
bchar = record
case byte of
0 : (bbyte : byte);
1 : (cchar : char);
end;
Var
Regs : Registers;
temp : bchar;
Begin
temp.cchar := ch; { Write a char to screen }
regs.ah := $09; { without any scrolling }
regs.al := temp.bbyte; { this is here so we can }
regs.bh := 0; { write to the last row/col}
regs.bl := attr; { in the window without }
regs.cx := count; { scrolling it! }
Intr($10,regs);
End;
Procedure Disp_SStr(sstr : String; Index : Integer);
Var
T1,T2,T3 : Char;
I : Integer;
irow : Integer;
ch : char;
swmin,swmax : Word;
swatt : Integer;
Begin
Case Wndw_Bdr of
1 : Begin
T1 := '╡';
T2 := '╞';
T3 := '═';
End;
2 : Begin
T1 := '┤';
T2 := '├';
T3 := '─';
End;
3 : Begin
T1 := '|';
T2 := '|';
T3 := '-';
End;
End;
SWMin := WindMin; { Save the current window }
SWMax := WindMax; { min/max coordinates }
Swatt := TextAttr;
WindMin := Save_WMin;
WindMax := Save_Wmax;
gotoxy(Col_Begin+2,Row_Begin+Row_Quan-1);
TextAttr := IAct_Attr;
if (Index <= 0) then
Wchars(t3,Iact_attr,6) { Erase any existing search string stuff }
else begin
Write(T1);
TextAttr := Act_Attr;
Write(' ',sstr,' ');
TextAttr := IAct_Attr;
Write(t2);
Wchars(t3,Iact_attr,2); { erase old '├' end marker... }
end;
WindMin := SWMin;
WindMax := SWmax;
TextAttr:= SWAtt;
End;
{
+----------------------------------------------------+
| Draw_Boarder |
+----------------------------------------------------+
}
Procedure Draw_Boarder(str : string);
Var
ULC : Char;
URC : Char;
LRC : Char;
LLC : Char;
HLINE : Char;
VLINE : Char;
TLFT : Char;
TRHT : Char;
I : Integer;
Begin
Case (Wndw_Bdr) of { define boarder elements }
{ based on global Wndw_Bdr }
1 : Begin
ULC := '╔';
URC := '╗';
LRC := '╝';
LLC := '╚';
HLINE := '═';
VLINE := '║';
TLFT := '╡';
TRHT := '╞';
End;
2 : Begin
ULC := '┌';
URC := '┐';
LRC := '┘';
LLC := '└';
HLINE := '─';
VLINE := '│';
TLFT := '┤';
TRHT := '├';
End;
3 : Begin
ULC := '+';
URC := '+';
LRC := '+';
LLC := '+';
HLINE := '-';
VLINE := '|';
TLFT := '|';
TRHT := '|';
End;
End; {Case}
gotoxy(1,1); { Draw the boarder }
write(ULC);
For i := 1 to (Col_Quan *15 +3) Do
write(HLINE);
write(URC);
For i := 2 to Row_Quan -1 Do
begin
gotoxy(1,i);
write(VLINE);
gotoxy((Col_Quan*15 + 5),i);
write(VLINE);
end;
gotoxy(1,Row_Quan);
write(LLC);
for i:=1 to (col_Quan*15+3) Do
write(HLINE);
wchars(LRC,IAct_Attr,1);
{ Put title on screen if it }
{ will fit }
if ((length(str) <> 0) And ((Length(str)+4) < (Col_Quan*15+3))) then
begin
gotoxy(3,1);
write(TLFT,' ',str,' ',TRHT);
end;
End;
{
+----------------------------------------------------+
| Procedure Make_Window |
+----------------------------------------------------+
}
Procedure Make_Window(title : String);
Var
x1,y1,x2,y2 : Byte;
ch : char;
Begin
Save_Screen; { Save the current screen }
TextAttr := IAct_Attr; { Define text color }
x1 := Col_Begin; { Define files window }
y1 := Row_Begin;
x2 := Col_Begin + (Col_Quan * 15) + 4;
y2 := Row_Begin + Row_Quan - 1;
Window(x1,y1,x2,y2); { Activate the window }
ClrScr; { Clear window to IAct_Attr }
If (Wndw_bdr <> 0) then
begin
Draw_Boarder(Title); { Draw the window boarder }
x1 := x1 + 1; { Redefine window so we don't }
x2 := x2 - 1; { scroll the boarder if there }
y1 := y1 + 1; { is one }
y2 := y2 - 1;
End;
Window(x1,y1,x2,y2); { Activate the window }
ClrScr; { Clear window to IAct_Attr }
End;
{
+----------------------------------------------------+
| Function Get_Files |
+----------------------------------------------------+
}
Function Get_Files(path : String; attr : Byte; Var First : Fptr) : Integer;
Var
p1,p2 : Fptr;
p3,p4 : Fptr;
nbrfils : Integer;
finfo : SearchRec;
placefound :boolean;
Begin
Get_Files := 0;
FindFirst(path,attr,finfo); { Find first matching file }
If DosError = 0 then { If we found a file... continue }
begin
new(p1); { allocate pointer to file name }
First := p1; { save a copy of it in First }
p1^.prev := nil; { set up prev/next pointers }
p1^.next := nil;
p1^.filnam := finfo.name; { copy in filename }
p2 := p1; { temp copy of ptr for next/prev }
nbrfils := 1; { init number of files found }
while DosError = 0 Do { get any additional files }
begin
FindNext(finfo); { find next matching file }
if (DosError = 0) then { if there are more continue }
begin
nbrfils := nbrfils + 1; { increment number files counter }
new(p1); { allocate new pointer }
p1^.filnam := finfo.name; { copy in file name }
p1^.next := Nil;
if (p1^.filnam < First^.filnam) Then begin
p1^.next := First;
First^.prev := p1;
First := p1;
end
else begin
p2 := First;
placefound := false;
while ((p2^.Next <> Nil) AND (Not Placefound)) Do Begin
if (p1^.filnam >= p2^.next^.filnam) then
p2 := p2^.next
else
placefound := true;
end;
p1^.next := p2^.next;
p1^.prev := p2;
p2^.next^.prev := p1;
p2^.next := p1;
end;
end;
end;
Get_Files := nbrfils; { return number of files found }
end;
end;
{
+----------------------------------------------------+
| Procedure Put_Files |
+----------------------------------------------------+
}
Procedure Put_Files (ptr : Fptr; maxfiles : integer);
Var
ptr2 : Fptr;
i,j,k,irow,icol : integer;
Begin
ptr2 := ptr; { put the files we found into }
irow := Row_Beg; { the files window }
icol := Col_Beg; { by traversing the file ptr }
{ linked list }
For i := 1 to maxfiles do
Begin
gotoxy(icol,irow);
write(ptr2^.filnam);
icol := icol + 15;
if (icol > F_Col_Max) Then
begin
irow := irow + 1;
icol := Col_Beg;
end;
if (ptr2^.next <> nil) Then
ptr2 := ptr2^.next
else
i := maxfiles;
end;
end;
{
+----------------------------------------------------+
| Function Srch_Dir |
+----------------------------------------------------+
}
Function Srch_Dir( ptr : Fptr; index : integer; sstr : sstr_type) : Fptr;
Var
ptr1 : Fptr;
found,done : boolean;
i : integer;
str1,str2 : string[12];
Begin
ptr1 := ptr;
found := false;
done := false;
str1 := sstr;
Srch_dir := Nil;
While ((ptr1 <> Nil) And (Not Found)) Do Begin
str2 := copy(ptr1^.filnam,1,index);
if str1 = str2 then begin
found := true;
Srch_Dir := Ptr1;
End
else
ptr1 := ptr1^.next;
End;
End;
{
+----------------------------------------------------+
| Function Prev_File |
+----------------------------------------------------+
}
Function Prev_File( ptr : Fptr; count : integer) : Fptr;
Var
ptr2,ptr3 : Fptr;
i,j,k,col2 : integer;
Begin
ptr2 := ptr; { back up one file }
j := count;
if (ptr2^.prev <> nil) then { is there a prev file? }
begin
Un_Highlight(ptr2); { unhighlight current file }
for i := 1 to j do { traverse file list while }
begin { updating the current row }
if (ptr2^.prev <> nil) Then { and col locs. }
begin
ptr2 := ptr2^.prev;
cur_col := cur_col - 15;
if (cur_col < col_beg) then
begin
cur_col := F_Col_Max;
Cur_Row := Cur_Row - 1;
if (Cur_Row < Row_Beg) Then
Begin { desired file not in wndw }
Cur_Row := Row_Beg; { scroll the display and }
GoToXY(1,1); { write out the new files }
InsLine;
ptr3 := ptr2;
col2 := cur_col;
for k := 1 to Col_Quan do
begin
gotoxy(col2,Cur_Row);
write(ptr3^.filnam);
if (ptr3^.prev <> Nil) Then
begin
ptr3 := ptr3^.prev;
col2 := col2 - 15;
end;
end;
end;
end;
end
else
i := count;
end;
highlight(ptr2); { all done, highlight }
end { new current filename }
else
beepit;
prev_file := ptr2;
end;
{
+----------------------------------------------------+
| Function Next_File |
+----------------------------------------------------+
}
Function Next_File( ptr : Fptr; count : integer) : Fptr;
Var
ptr2,ptr3 : Fptr;
i,j,k,col2 : integer;
Begin
ptr2 := ptr; { same as prev_file but in }
j := count; { other direction }
if (ptr2^.Next <> nil) then
begin
Un_Highlight(ptr2);
for i := 1 to j do
begin
if (ptr2^.Next <> nil) Then
begin
ptr2 := ptr2^.Next;
cur_col := cur_col + 15;
if (cur_col > F_Col_Max) then
begin
cur_col := Col_Beg;
Cur_Row := Cur_Row + 1;
if (Cur_Row > F_Row_Max) then
Begin
Cur_Row := F_Row_Max;
GoToXY(1,1);
DelLine;
ptr3 := ptr2;
col2 := cur_col;
for k := 1 to Col_Quan do
begin
gotoxy(col2,Cur_Row);
write(ptr3^.filnam);
if (ptr3^.Next <> Nil) Then
begin
ptr3 := ptr3^.Next;
col2 := col2 + 15;
end;
end;
end;
end;
end
else
i := count;
end;
highlight(ptr2);
end
else
beepit;
Next_file := ptr2;
end;
{
+----------------------------------------------------+
| Procedure SetLim |
+----------------------------------------------------+
}
Procedure SetLim;
Var
Bad_Parms : Boolean;
Begin
Bad_Parms := FALSE; { Allow the user to define }
{ the location and limits }
if ((rowb < 1) OR (rowb > 25)) Then { of the file selection }
Bad_Parms := TRUE; { window. Make sure parms }
if ((colb < 1) OR (colb > 65)) Then { are within tolerable }
Bad_Parms := TRUE; { limits before we accept }
if ((rowq < 1) OR (rowb+rowq > 25)) Then { them. }
Bad_Parms := TRUE;
if ((colq < 1) OR (colb+colq > 80)) Then
Bad_Parms := TRUE;
if ((active < 0) OR (active > 255)) Then
Bad_Parms := TRUE;
if ((inactive < 0) OR (inactive > 255)) Then
Bad_Parms := TRUE;
if ((boarder < 0) OR (boarder > 3)) Then
Bad_Parms := TRUE;
if (Bad_Parms = FALSE) Then { Parms ok...update our }
Begin { global variables }
Row_Begin := rowb;
Col_Begin := colb;
Row_Quan := rowq;
Col_Quan := colq;
Act_Attr := active;
IAct_Attr := inactive;
Wndw_Bdr := boarder;
End;
End;
{
+----------------------------------------------------+
| Function Sel_File |
+----------------------------------------------------+
}
Function Sel_File;
Var
FFile : Fptr;
ptr1 : Fptr;
ptr2 : Fptr;
ptr3 : Fptr;
ptr4 : Fptr;
hptr : Pointer;
indx : Integer;
RC : String[3];
iopt : Integer;
Max_Files : Integer;
Max_Scrn : Integer;
Col_Offset : Integer;
ch : char;
done : boolean;
temp : Integer;
Sindex : Integer;
SSTR : sstr_type;
Begin { Procedure Sel_File }
{ save the current heap Pointer }
New(hptr);
Mark(hptr);
sstr := '';
sindex := 0;
Max_Files := Get_Files(path, attribute, FFile);{ get matching files }
if (Max_Files <> 0) then { proceed if we found files }
begin
Col_Beg := 3; { define some window limits }
Row_Beg := 1;
F_Col_Max := (Col_Beg + ((Col_Quan - 1) * 15));
If (Wndw_Bdr <> 0) Then { Compute Max rows of files }
F_Row_Max := Row_Quan - 2
Else
F_Row_Max := Row_Quan;
ptr1 := FFile;
Max_Scrn := Col_Quan * F_Row_Max; { Compute Max files within wndw }
if (Max_Scrn > Max_Files) Then Max_Scrn := Max_Files;
Cursor(FALSE); { Turn off the cursor }
make_window(Title); { Draw the files window }
Put_Files(ptr1,Max_Scrn); { fill window w/ avail files }
Cur_Row := Row_Beg; { init cur row/col }
Cur_Col := Col_Beg;
Highlight(ptr1); { highlight first file }
Done := False; { continue till user selects a }
While (Not Done) Do { file or quits }
Begin
ch := ReadKey;
if (ch = #0) then begin
ch := ReadKey;
case ch of
#75 : ptr1 := prev_file(ptr1,1); { Left Arrow }
#77 : ptr1 := next_file(ptr1,1); { Right Arrow }
#72 : ptr1 := prev_file(ptr1,Col_Quan);{ Up Arrow }
#80 : ptr1 := next_file(ptr1,Col_Quan);{ Down Arrow }
#73 : ptr1 := prev_file(ptr1,Max_Scrn);{ Page Up }
#81 : ptr1 := next_file(ptr1,Max_Scrn);{ Page Down }
#59 : Begin
Sel_File := 2;
Fil_Nam := '';
Done := True;
End;
end;
End
Else
Begin
Case ch of
#13 : begin { Return Key }
Fil_Nam := ptr1^.filnam; { return highlighted }
Sel_File := 1;
Done := True; { file to caller }
end;
#27 : begin { Escape }
sel_file := 0; { user quit }
Fil_Nam := '';
Done := True;
End;
#8 : begin
Sindex := Sindex - 1;
if (Sindex <= 0) Then begin
Sindex := 0;
sstr := '';
end
else
sstr := copy(sstr,1,sindex);
End;
Else Begin
ch := upcase(ch);
If ((ch > #32) and (ch < #127)) then begin
SIndex := Sindex + 1;
If (Sindex > 12) Then
Sindex := 12
Else
sstr := concat(sstr,ch);
End;
End;
end;
Disp_sstr(sstr,sindex);
If (Sindex <> 0) then begin
ptr3 := Srch_Dir(FFile,Sindex,SSTR);
if (ptr3 = Nil) Then
beepit
else begin
If (ptr3 = FFile) Then Begin
While(ptr1 <> ptr3) Do
ptr1 := Prev_File(Ptr1,1);
End
Else Begin
ptr4 := FFile;
While (ptr4 <> ptr3) Do Begin
if (ptr4 = ptr1) Then Begin { found cur file before sfile}
While(ptr1 <> ptr3) Do Begin
ptr1 := next_file(ptr1,1);
ptr4 := ptr1;
end;
end
else begin
ptr4 := ptr4^.next;
if (ptr4 = ptr3) Then Begin { found sfile before cur file}
While(ptr1 <> ptr3) Do Begin
ptr1 := prev_file(ptr1,1);
end;
end;
end;
end;
End;
end;
end;
End;
end;
Restore_Screen; { restore the screen }
end
else
begin
Sel_File := -1; { no files found...return null }
Fil_Nam := '';
End;
Release(hptr); { restore all mem allocated }
Cursor(True); { turn cursor back on }
end;
{
+----------------------------------------------------+
| Define Unit Initialization Section |
+----------------------------------------------------+
}
Begin
Row_Begin := 1; { Define default file selection }
Col_Begin := 1; { window as the entire screen }
Row_Quan := 24;
Col_Quan := 5;
Act_Attr := LHIGHLITE; { Define default video attributes}
IAct_Attr := LNORMAL;
Wndw_Bdr := DEF_BDR;
end.
